home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / calls.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  10KB  |  445 lines
  1. /* ******************************************************************** */
  2. /*  calls.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* explicit funcalls                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, March 1990 (Compiler rationalisation) 
  10.  */
  11.  
  12. #include "funcalls.h"
  13. #include "defs.h"
  14. #include "structs.h"
  15.  
  16. #include "error.h"
  17. #include "global.h"
  18.  
  19. #include "allocate.h"
  20. #include "lists.h"
  21. #include "modules.h"
  22. #include "modboot.h"
  23. #include "class.h"
  24.  
  25. #include "calls.h"
  26.  
  27. EUFUN_1( Fn_functionp, obj)
  28. {
  29.   return(EUCALL_2(Fn_subclassp,classof(obj),Function));
  30. }
  31. EUFUN_CLOSE
  32.  
  33. EUFUN_1( Fn_real_functionp, obj)
  34. {
  35.   LispObject a;
  36.   EUCALLSET_2(a, Fn_subclassp, classof(obj), Function);
  37.   obj = ARG_0(stackbase);
  38.   return ((a!=nil && !is_macro(obj)) ? lisptrue : nil);
  39. }
  40. EUFUN_CLOSE
  41.  
  42. EUFUN_1( Fn_function_lambda_list, form)
  43. {
  44.   while (!is_function(form))
  45.     form = CallError(stacktop,
  46.              "Not function in function-lambda-list",form,CONTINUABLE);
  47.   if (is_i_function(form)) return (form->I_FUNCTION).bvl;
  48.   if (is_c_function(form)) {
  49.     int args = form->C_FUNCTION.argtype;
  50.     LispObject ans = nil;
  51.     LispObject tt = nil;
  52.     char *name = 
  53.        "@\0a\0b\0c\0d\0e\0f\0g\0h\0i\0j\0k\0l\0m\0n\0o\0p\0q\0r\0s\0t\0u\0v\0w\0x\0y\0z";
  54.     if (args<0) {
  55.       ans = (LispObject)get_symbol(stacktop,"@");
  56.       args = -args-1;
  57.     }
  58.     while (args>0) {
  59.       STACK_TMP(ans);
  60.       tt = (LispObject)get_symbol(stacktop,name+2*args);
  61.       UNSTACK_TMP(ans);
  62.       EUCALLSET_2(ans, Fn_cons, tt, ans);
  63.       args--;
  64.     }
  65.     return ans;
  66.   }
  67.   fprintf(stderr,"What is an e-function??\n");
  68.   return nil;
  69. }
  70. EUFUN_CLOSE
  71.  
  72. EUFUN_2( Fn_apply, fun, args)
  73. {
  74.   LispObject ret;
  75.   /* args are automatically listed so... */
  76.   EUCALLSET_2(ret,module_mv_apply_1,fun,args);
  77.   return(ret);
  78. }
  79. EUFUN_CLOSE
  80.  
  81. static LispObject nary_apply_aux(LispObject *stacktop, LispObject l)
  82. {
  83.   LispObject xx;
  84.   if (l == nil) return(nil);
  85.   if (!is_cons(CDR(l))) {
  86.     if (!is_cons(CAR(l)) && CAR(l) != nil)
  87.       CallError(stacktop,"apply: bad list",CAR(l),NONCONTINUABLE);
  88.     else
  89.       return(CAR(l));
  90.   }
  91.   STACK_TMP(CAR(l));
  92.   xx = nary_apply_aux(stacktop,CDR(l));
  93.   UNSTACK_TMP(l);
  94.   return(EUCALL_2(Fn_cons, l, xx));
  95. }
  96.  
  97. EUFUN_2( Fn_nary_apply, fun, stuff)
  98. {
  99.   LispObject ans;
  100.  
  101.   ans = nary_apply_aux(stacktop,stuff);
  102.   EUCALLSET_2(ans, Fn_apply, ARG_0(stackbase), ans);
  103.   return(ans);
  104. }
  105. EUFUN_CLOSE
  106.  
  107. EUFUN_2( apply1, fun, arg)
  108. {
  109.   if (EUCALL_1(Fn_functionp,fun) != nil) {
  110.     LispObject ret;
  111.  
  112.     EUCALLSET_2(arg, Fn_cons,ARG_1(stackbase),nil); /* Multiple valuize */
  113.     EUCALLSET_2(ret,module_mv_apply_1,ARG_0(stackbase),arg);
  114.     return ret;
  115.   }
  116.  
  117.   CallError(stacktop,"apply1: invalid operator",fun,NONCONTINUABLE);
  118.  
  119.   return(nil);
  120. }
  121. EUFUN_CLOSE
  122.  
  123. EUFUN_3( apply2, fun, arg1, arg2)
  124. {
  125.   if (EUCALL_1(Fn_functionp, fun) != nil) {
  126.     LispObject ret;
  127.  
  128.     EUCALLSET_2(arg2,Fn_cons,arg2,nil); /* Multiple valuize */
  129.     EUCALLSET_2(arg1,Fn_cons,ARG_1(stackbase),arg2);
  130.     EUCALLSET_2(ret,module_mv_apply_1,ARG_0(stackbase),arg1);
  131.     return ret;
  132.   }
  133.  
  134.   CallError(stacktop,"apply2: invalid operator",fun,NONCONTINUABLE);
  135.  
  136.   return(nil);
  137. }
  138. EUFUN_CLOSE
  139.  
  140. EUFUN_2( macroexpand_1, mod, exp)
  141. {
  142.   LispObject op,ret;
  143.   LispObject bind;
  144.  
  145.   if (!is_cons(exp)) {
  146.     EUCALLSET_2(ret, Fn_cons, nil,nil);
  147.     EUCALLSET_2(ret, Fn_cons, ARG_1(stackbase),ret);
  148.     return(ret);
  149.   }
  150.  
  151.   exp=ARG_1(stackbase);
  152.   op = CAR(exp); 
  153.  
  154.   if (!is_symbol(op)) {
  155.     EUCALLSET_2(ret, Fn_cons, nil,nil);
  156.     EUCALLSET_2(ret, Fn_cons, ARG_1(stackbase),ret);
  157.     return(ret);
  158.   }
  159.  
  160.   mod=ARG_0(stackbase);
  161.   /* HACK !!! Should really be imported test */
  162.   bind=GET_BINDING(mod,op);
  163.   if (bind==nil) {
  164.     EUCALLSET_2(ret, Fn_cons, nil,nil);
  165.     EUCALLSET_2(ret, Fn_cons, ARG_1(stackbase),ret);
  166.     return(ret);
  167.   }  
  168.  
  169.   op = symbol_ref(stacktop,mod,NULL,op);
  170.   
  171.   if (!is_macro(op)) {
  172.     EUCALLSET_2(ret, Fn_cons, nil,nil);
  173.     EUCALLSET_2(ret, Fn_cons, ARG_1(stackbase),ret);
  174.     return(ret);
  175.   }
  176.  
  177.   /* What a dumb order... I'll rewrite it later (?) */
  178.  
  179.   EUCALLSET_2(ret,module_mv_apply_1,op,CDR(exp));
  180.   STACK_TMP(ret);
  181.   EUCALLSET_2(exp, Fn_cons, lisptrue, nil);
  182.   UNSTACK_TMP(ret);
  183.   EUCALLSET_2(ret, Fn_cons, ret, exp);
  184.   return(ret);
  185. }
  186. EUFUN_CLOSE
  187.  
  188. EUFUN_3( Sf_macroexpand_1, mod, env, forms)
  189. {
  190.   LispObject ret;
  191.  
  192.   if (!is_cons(forms))
  193.     CallError(stacktop,"macroexpand-1: null form",forms,NONCONTINUABLE);
  194.  
  195.   EUCALLSET_2(ret, macroexpand_1,mod,CAR(forms));
  196.  
  197.   return(ret);
  198. }
  199. EUFUN_CLOSE
  200.  
  201. EUFUN_3( Sf_macroexpand, mod, env, forms)
  202. {
  203.   LispObject last,res,exp;
  204.  
  205.   if (!is_cons(forms))
  206.     CallError(stacktop,"macroexpand: null form",forms,NONCONTINUABLE);
  207.  
  208.   exp = CAR(forms);
  209.   
  210.   res = nil;
  211.  
  212.   do {
  213.  
  214.     last = res;
  215.     STACK_TMP(last);
  216.     mod = ARG_0(stackbase);
  217.     EUCALLSET_2(res, macroexpand_1, mod, exp);
  218.     UNSTACK_TMP(last); 
  219.     exp = CAR(res);
  220.  
  221.   } while (CAR(CDR(res)) != nil);
  222.  
  223.   if (last != nil)
  224.     return(last);
  225.   else
  226.     return(res);
  227. }
  228. EUFUN_CLOSE
  229.  
  230. /* Macroexpand with this macro... */
  231.  
  232. EUFUN_2( Fn_apply_macro, macro, form)
  233. {    
  234.   LispObject ret;
  235.  
  236.   if (!is_macro(macro))
  237.     CallError(stacktop,"apply-macro: non-macro",macro,NONCONTINUABLE);
  238.  
  239.   EUCALLSET_2(ret,module_mv_apply_1,macro,form);    
  240.   return ret;
  241. }
  242. EUFUN_CLOSE
  243.  
  244. /* Predicate... */
  245.  
  246. EUFUN_1( Fn_macrop, obj)
  247. {
  248.  
  249.   return( is_macro(obj) ? lisptrue : nil);
  250.  
  251. }
  252. EUFUN_CLOSE
  253.  
  254.  
  255. /*******    
  256.  * modified handler interactions
  257.  *
  258.  *******/
  259.  
  260. EUFUN_1(Fn_push_handler,handler)
  261. {
  262.   HANDLER_STACK() = EUCALL_2(Fn_cons,handler,HANDLER_STACK());
  263.   
  264.   return (HANDLER_STACK());
  265. }
  266. EUFUN_CLOSE
  267.  
  268. EUFUN_0(Fn_pop_handler)
  269. {
  270.   HANDLER_STACK() = CDR(HANDLER_STACK());
  271.   
  272.   return HANDLER_STACK();
  273. }
  274. EUFUN_CLOSE
  275.  
  276. /* I'll never write a complicated one (in C) */
  277. EUFUN_1(Fn_simple_call_cc,fn)
  278. {
  279.   LispObject cont;
  280.   LispObject args;
  281.   LispObject val;
  282.  
  283.   cont=allocate_continue(stacktop);
  284.   
  285.   STACK_TMP(cont);
  286.  
  287.   if (set_continue(stacktop,cont))
  288.     {    /* forcible return */
  289.  
  290.       UNSTACK_TMP(cont);
  291.       return(cont->CONTINUE.value);
  292.     }
  293.  
  294.   UNSTACK_TMP(cont);
  295.   STACK_TMP(cont);
  296.   args=EUCALL_2(Fn_cons,cont,nil);
  297.  
  298.   val=EUCALL_2(module_mv_apply_1,ARG_0(stackbase)/*fn*/,args);
  299.   UNSTACK_TMP(cont);
  300.   unset_continue(cont);
  301.   return(val);
  302.  
  303. }
  304. EUFUN_CLOSE
  305.  
  306. EUFUN_2(Fn_unwind_protect, protected_fn, exit_fn)
  307. {
  308.   void call_continuation(LispObject *,LispObject, LispObject);
  309.   LispObject cont,val;
  310.  
  311.   cont = allocate_continue(stacktop); /* Allocate and freeze */
  312.   protected_fn = ARG_0(stackbase);
  313.   exit_fn = ARG_1(stackbase);
  314.   STACK_TMP(cont);
  315.   if (set_continue(stacktop,cont))
  316.     {
  317.       /** Invoked **/
  318.       EUCALL_2(module_mv_apply_1,ARG_1(stackbase)/*exit_fn*/,nil);
  319.       UNSTACK_TMP(cont);
  320.       call_continuation(stacktop,cont->CONTINUE.target,cont->CONTINUE.value);
  321.     }
  322.       
  323.   cont->CONTINUE.unwind=TRUE;
  324.   val=EUCALL_2(module_mv_apply_1,ARG_0(stackbase)/*protected_fn*/,nil);
  325.  
  326.   /* kill cont */
  327.   UNSTACK_TMP(cont);
  328.   unset_continue(cont);
  329.   
  330.   /* exit stuff */
  331.   STACK_TMP(val);
  332.   val=EUCALL_2(module_mv_apply_1,ARG_1(stackbase)/*exit_fn*/,nil);
  333.   UNSTACK_TMP(val);
  334.  
  335.   return val;
  336. }
  337. EUFUN_CLOSE
  338.  
  339. /*
  340.  * The continuation hacking special forms
  341.  */
  342.  
  343. void call_continuation(LispObject *stacktop,LispObject cont,LispObject value)
  344. {
  345.   LispObject last;
  346.  
  347.   /* First, check the continuation's still live... */
  348.  
  349.   if (!cont->CONTINUE.live)
  350.     CallError(stacktop,"continuation call: dead continuation",cont,NONCONTINUABLE);
  351.  
  352.   if (cont->CONTINUE.thread != CURRENT_THREAD())
  353.     CallError(stacktop,
  354.           "continuation call: not on this thread",cont,NONCONTINUABLE);
  355.  
  356.   /* That's cool, now wander down (up?) the dynamic continuation list
  357.              killing stuff off and looking for unwind protects        */
  358.  
  359.   last = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue);
  360.  
  361.   while (last != cont) {
  362.  
  363.     if (last == nil) {
  364.       fprintf(stderr,"AARRRRGGHHH!!!: continuation vanished!");
  365.       exit(1);
  366.     }
  367.  
  368.     if (last->CONTINUE.unwind) {
  369.       LispObject temp;
  370.  
  371.       /* We have an unwind continuation */
  372.  
  373.       /* Leave interesting info for unwind-protect */
  374.  
  375.       last->CONTINUE.target = cont;
  376.       last->CONTINUE.value = value;
  377.  
  378.       /* Kill this unwind continuation */
  379.  
  380.       temp = last;
  381.       last 
  382.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue) 
  383.       = temp->CONTINUE.last_continue;
  384.  
  385.       /* Jump... */
  386.  
  387.       call_continue(stacktop,temp,value);
  388.  
  389.     }
  390.  
  391.     /* Normal continuation - kill it ! */
  392.  
  393.     {
  394.       LispObject temp;
  395.  
  396.       temp = last->CONTINUE.last_continue;
  397.       last->CONTINUE.live = FALSE;
  398.       last->CONTINUE.last_continue = nil;
  399.       last = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue) = temp;
  400.  
  401.     }
  402.  
  403.   }
  404.  
  405.   /* We've hit our own, so all is hunkydory */
  406.  
  407.   /* Jump away... */
  408.  
  409.   call_continue(stacktop,cont,value);
  410.  
  411. } 
  412.  
  413. /*
  414.  
  415.  * Initialise calls
  416.  
  417.  */
  418.  
  419. #define CALLS_ENTRIES 11
  420. MODULE Module_calls;
  421. LispObject Module_calls_values[CALLS_ENTRIES];
  422.  
  423. void initialise_calls(LispObject *stacktop)
  424. {
  425.   open_module(stacktop,
  426.           &Module_calls,
  427.           Module_calls_values,
  428.           "calls",
  429.           CALLS_ENTRIES);
  430.  
  431.   (void) make_module_function(stacktop,"apply",Fn_nary_apply,-2);
  432.   (void) make_module_special(stacktop,"macroexpand-1",Sf_macroexpand_1);
  433.   (void) make_module_special(stacktop,"macroexpand",Sf_macroexpand);
  434.   (void) make_module_function(stacktop,"apply-macro",Fn_apply_macro,2);
  435.   (void) make_module_function(stacktop,"macrop",Fn_macrop,1);
  436.   (void) make_module_function(stacktop,"functionp",Fn_real_functionp,1);
  437.   (void) make_module_function(stacktop,"function-lambda-list",Fn_function_lambda_list,1);
  438.  
  439.   (void) make_module_function(stacktop,"push-handler",Fn_push_handler,1);
  440.   (void) make_module_function(stacktop,"pop-handler",Fn_pop_handler,0);
  441.   (void) make_module_function(stacktop,"simple-call/cc",Fn_simple_call_cc,1);
  442.   (void) make_module_function(stacktop,"fn-unwind-protect",Fn_unwind_protect,2);
  443.   close_module();
  444. }
  445.